SuperHack/SuperHack CD.bin/CODING/DEMOS/RT_AZ.ZIP/COMPO.PAS

Pascal/Delphi Source File | 1995-08-21 | 5.5 KB | 217 lines

{$A-,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 16384,0,655360}
const
    ON          = true;
    OFF         = false;
type
    pArrOfByte  = ^tArrOfByte;
    tArrOfByte  = array[0..65000] of Byte;
    tVGApalette = array[0..256*3-1] of Byte;
    tCEL        = record
                   Picture : pArrOfByte;
                   Palette : pArrOfByte;
                  end;

var CEL         : tCEL;
    Palette     : tVGApalette;
    SinTable    : array[0..255] of Word;

Function ReadKey : Word; assembler;
asm
                xor     ax,ax
                int     16h
end;

Procedure InitMode; assembler;
asm             mov     ax,0013h
                int     10h
end;

Procedure SetVGApalette(var Palette; StartCol,Num : Word); assembler;
asm             les     si,Palette
                mov     ax,StartCol
                mov     bx,ax
                shl     ax,1
                add     si,ax
                add     si,bx
                mov     cx,Num
                mov     bx,cx
                shl     cx,1
                add     cx,bx
                mov     dx,03DAh
@@w1:           in      al,dx
                test    al,8
                jnz     @@w1
@@w2:           in      al,dx
                test    al,8
                jz      @@w2
                mov     dx,03C8h
                mov     ax,StartCol
                out     dx,al
                inc     dx
                SegES   rep outsb
end;

Procedure FadeIn(Scale : Word);
var I : Integer;
begin
 For I := 0 to 767 do
  Palette[I] := Scale * CEL.Palette^[I] div 64;
 SetVGApalette(Palette, 0, 256);
end;

Function LoadCEL(const fName : String) : boolean;
var F : File;
begin
 LoadCEL := OFF;
 Assign(F, fName); Reset(F, 1);
 if ioResult <> 0 then Exit;
 GetMem(CEL.Picture, 320*200);
 GetMem(CEL.Palette, 256*3);
 if CEL.Picture = nil then Exit;
 if CEL.Palette = nil then Exit;
 Seek(F, 32); {Skip header}
 BlockRead(F, CEL.Palette^, 768);
 BlockRead(F, CEL.Picture^, 320*200);
 if ioResult <> 0
  then begin Close(F); Exit; end;
 Close(F);
 LoadCEL := ON;
end;

Procedure ShowLine(srcLine,dstX,dstY : Integer; Scale : Word); assembler;
var lStart : Word;
    sDelta : Byte;
asm             cld
                push    ds
                mov     ax,dstY
                cmp     ax,199
                ja      @@locEx
                cmp     Scale,2
                jb      @@locEx
                mov     es,segA000
                lds     si,CEL.Picture
                mov     cx,320
                mov     ax,cx
                mul     srcLine
                add     si,ax
                mov     ax,cx
                mul     dstY
                mov     di,ax
                mov     lStart,ax
                mov     bx,dstX
                mov     dx,0001h
                mov     ax,4000h
                div     Scale
                mov     cx,ax
                test    cx,cx
                jz      @@locEx

                mov     sDelta,0
                cmp     dstX,-1
                jne     @@noCenter
                mov     ax,320
                sub     ax,cx
                sar     ax,1
                inc     ax
                add     bx,ax

@@noCenter:     test    bx,bx
                jns     @@noClipL
                mov     ax,bx
                neg     ax
                sub     cx,ax
                jle     @@locEx
                mul     Scale
                mov     sDelta,al
                mov     al,ah
                mov     ah,dl
                add     si,ax
                xor     bx,bx
@@noClipL:      mov     ax,320
                sub     ax,dstX
                cmp     ax,cx
                ja      @@noClipR
                mov     cx,ax
                jcxz    @@locEx
@@noClipR:      push    cx
                mov     cx,bx
                xor     ax,ax
                shr     cx,1
                rep     stosw
                adc     cl,cl
                rep     stosb
@@noFillL:      pop     cx
                mov     dx,Scale
                mov     bh,sDelta
                mov     bl,dl
                mov     dl,dh
                mov     dh,0
@@scale:        mov     al,[si]
                add     bh,bl
                adc     si,dx
                stosb
                loop    @@scale

                xor     ax,ax
                mov     cx,lStart
                add     cx,320
                sub     cx,di
                jle     @@locEx
                shr     cx,1
                rep     stosw
                adc     cl,cl
                rep     stosb

@@locEx:        pop     ds
end;

Procedure ShowCELmode1;
var Y,CSP,CDS,SP : Integer;
begin
 InitMode;
 For Y := 10 to 256 do
  begin
   FadeIn(Y div 4);
   For CSP := 0 to 199 do
    ShowLine(CSP, -1, CSP, Y);
  end;
 readkey;
end;

Procedure ShowCELmode2;
var Y,SP : Integer;
begin
 InitMode;
 For Y := -320 to 320 do
  begin
   FadeIn((320-abs(Y)) * 64 div 320);
   For SP := 0 to 199 do
    ShowLine(SP, Y, SP, 256);
  end;
 readkey;
end;

Procedure InitViewer;
var I : Word;
begin
 For I := 0 to 255 do
  SinTable[I] := Round(Sin(I * (2 * pi) / 256) * 16384);
end;

begin
 if paramCount <> 1
  then begin
        Writeln('Usage: Show <filename.cel>');
        Halt(1);
       end;
 if not LoadCEL(ParamStr(1))
  then begin
        Writeln('Cannot load picture file');
        Halt(1);
       end;
 InitViewer;
 ShowCELmode1;
 ShowCELmode2;
end.